home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
archiver
/
dearc31.zip
/
DEARCLZW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-07-26
|
12KB
|
613 lines
(**
*
* Module: dearclzw.pas
* Description: DEARC Lempel-Ziv-Welch decompression routines
* (that is, unsquashing and uncrunching)
*
* Revision History:
* 7-26-88: unitized for Turbo v4.0
*
**)
unit dearclzw;
interface
uses
dearcabt,
dearcglb,
dearcio,
dearcunp;
procedure init_ucr ( i : integer );
function getc_ucr : integer;
procedure decomp ( SquashFlag : integer );
implementation
(*
* definitions for uncrunch / unsquash
*)
Const
TABSIZE = 4096;
TABSIZEM1 = 4095;
NO_PRED : word = $FFFF;
EMPTY : word = $FFFF;
Type
entry = record
used : boolean;
next : integer;
predecessor : integer;
follower : byte
end;
Var
stack : array [0..TABSIZEM1] of byte;
sp : integer;
string_tab : array [0..TABSIZEM1] of entry;
Var
code_count : integer;
code : integer;
firstc : boolean;
oldcode : integer;
finchar : integer;
inbuf : integer;
outbuf : integer;
newhash : boolean;
(*
* definitions for dynamic uncrunch
*)
Const
Crunch_BITS = 12;
Squash_BITS = 13;
HSIZE = 8192;
INIT_BITS = 9;
FIRST = 257;
CLEAR = 256;
HSIZEM1 = 8191;
BITSM1 = 12;
RMASK : array[0..8] of byte = ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);
Var
bits,
n_bits,
maxcode : integer;
prefix : array[0..HSIZEM1] of integer;
suffix : array[0..HSIZEM1] of byte;
buf : array[0..BITSM1] of byte;
clear_flg : integer;
stack1 : array[0..HSIZEM1] of byte;
free_ent : integer;
maxcodemax : integer;
offset,
sizex : integer;
(**
*
* Name: function h
* Description: calculate hash value for LZW compression
* thanks to Bela Lubkin
* Parameters: value -
* pred, foll : integer - pred and follower bytes
* Returns: new hash value
*
**)
function h(pred, foll : integer) : integer;
{ pbr - removed messy real-to-int stuff - not necessary in TP4 }
var
Local : longint;
V : word;
begin
if not newhash then
Local := (pred + foll) or $0800
else
Local := (pred + foll) * 15073;
h := integer(local and $0FFF);
end;
(**
*
* Name: function eolist
* Description: find end of an LZW chain
* Parameters: value -
* index : integer - start of chain
* Returns: last entry in chain
*
**)
function eolist(index : integer) : integer;
var temp : integer;
begin
temp := string_tab[index].next;
while temp <> 0 do
begin
index := temp;
temp := string_tab[index].next
end;
eolist := index
end; (* func eolist *)
(**
*
* Name: function hash
* Description: add pred/foll pair to LZW hash table
* Parameters: value -
* pred, foll : integer - pair to add
* Returns: new pred val
*
**)
function hash(pred, foll : integer) : integer;
var
local : integer;
tempnext : integer;
begin
local := h(pred, foll);
if not string_tab[local].used then
hash := local
else
begin
local := eolist(local);
tempnext := (local + 101) and $0FFF;
while string_tab[tempnext].used do
begin
tempnext := tempnext + 1;
if tempnext = TABSIZE then
tempnext := 0
end;
string_tab[local].next := tempnext;
hash := tempnext
end
end; (* func hash *)
(**
*
* Name: procedure upd_tab
* Description: update LZW hash table entry
* Parameters: value -
* pred, foll : integer - pair to update
*
**)
procedure upd_tab(pred, foll : integer);
begin
with string_tab[hash(pred, foll)] do
begin
used := TRUE;
next := 0;
predecessor := pred;
follower := foll
end
end; (* proc upd_tab *)
(**
*
* Name: function gocode : integer
*
**)
function gocode : integer;
label
exit;
var
localbuf : integer;
returnval : integer;
begin
if inbuf = EMPTY then
begin
localbuf := getc_unp;
if localbuf = -1 then
begin
gocode := -1;
goto exit (******** was "exit" ************)
end;
localbuf := localbuf and $00FF;
inbuf := getc_unp;
if inbuf = -1 then
begin
gocode := -1;
goto exit (******** was "exit" ************)
end;
inbuf := inbuf and $00FF;
returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
inbuf := inbuf and $000F
end
else
begin
localbuf := getc_unp;
if localbuf = -1 then
begin
gocode := -1;
goto exit (******** was "exit" ************)
end;
localbuf := localbuf and $00FF;
returnval := localbuf + ((inbuf shl 8) and $0F00);
inbuf := EMPTY
end;
gocode := returnval;
exit:
end; (* func gocode *)
(**
*
* Name: procedure push
* Description: push a char onto LZW 'pending' stack
* Parameters: value -
* c : integer - value to push
*
**)
procedure push(c : integer);
begin
stack[sp] := c;
sp := sp + 1;
if sp >= TABSIZE then
abort('Stack overflow')
end; (* proc push *)
(**
*
* Name: function pop : integer
* Description: pop a character from LZW 'pending' stack
* Parameters: none
* Returns: character popped or EMPTY
*
**)
function pop : integer;
begin
if sp > 0 then
begin
sp := sp - 1;
pop := stack[sp]
end
else
pop := EMPTY
end; (* func pop *)
(**
*
* Name: procedure init_tab
* Description: initialize LZW string table
* Parameters: none
*
**)
procedure init_tab;
var
i : integer;
begin
FillChar(string_tab, sizeof(string_tab), 0);
for i := 0 to 255 do
upd_tab(NO_PRED, i);
inbuf := EMPTY;
end; (* proc init_tab *)
(**
*
* Name: procedure init_ucr
* Description: init LZW routines
* Parameters: value -
* i : integer - hash seed
*
**)
procedure init_ucr(i:integer);
begin
newhash := i = 1;
sp := 0;
init_tab;
code_count := TABSIZE - 256;
firstc := TRUE
end; (* proc init_ucr *)
(**
*
* Name: function getc_ucr : integer
* Description: get next (uncompressed) LZW character
* Parameters: none
* Returns: next character
*
**)
function getc_ucr : integer;
label exit;
var c : integer;
code : integer;
newcode : integer;
begin
if firstc then
begin
firstc := FALSE;
oldcode := gocode;
finchar := string_tab[oldcode].follower;
getc_ucr := finchar;
goto exit (******** was "exit" ************)
end;
if sp = 0 then
begin
newcode := gocode;
code := newcode;
if code = -1 then
begin
getc_ucr := -1;
goto exit (******** was "exit" ************)
end;
if not string_tab[code].used then
begin
code := oldcode;
push(finchar)
end;
while string_tab[code].predecessor <> NO_PRED do
with string_tab[code] do
begin
push(follower);
code := predecessor
end;
finchar := string_tab[code].follower;
push(finchar);
if code_count <> 0 then
begin
upd_tab(oldcode, finchar);
code_count := code_count - 1
end;
oldcode := newcode
end;
getc_ucr := pop;
exit:
end; (* func getc_ucr *)
(**
*
* Name: function getcode : integer
* Description:
* Parameters: var -
*
* value -
*
* Returns:
*
**)
function getcode : integer;
label
ne